home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / x11 / x-menubar.el < prev    next >
Encoding:
Text File  |  1995-08-29  |  35.1 KB  |  994 lines
  1. ;;; x-menubar.el --- Menubar and popup-menu support for X.
  2.  
  3. ;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
  4. ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
  5. ;; Copyright (C) 1995 Sun Microsystems.
  6.  
  7. ;; This file is part of XEmacs.
  8.  
  9. ;; XEmacs is free software; you can redistribute it and/or modify it
  10. ;; under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; XEmacs is distributed in the hope that it will be useful, but
  15. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17. ;; General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with Xmacs; see the file COPYING.  If not, write to the Free
  21. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  22.  
  23. (defconst default-menubar
  24.   (purecopy-menubar
  25.    '(
  26.      ("File"
  27.       :filter file-menu-filter
  28.       ["Open..."        find-file        t]
  29.       ["Open in Other Window..." find-file-other-window    t]
  30.       ["Open in New Frame..."    find-file-other-frame    t]
  31.       ["Insert File..."     insert-file        t]
  32.       ["View File..."        view-file        t]
  33.       "------"
  34.       ["Save"            save-buffer        t  nil]
  35.       ["Save As..."        write-file        t]
  36.       ["Save Some Buffers"    save-some-buffers    t]
  37.       "-----"
  38.       ["Print Buffer"        lpr-buffer        t  nil]
  39.       ["Pretty-Print Buffer"    ps-print-buffer-with-faces t  nil]
  40.       "-----"
  41.       ["New Frame"        make-frame        t]
  42.       ["Delete Frame"        delete-frame        t]
  43.       "-----"
  44.       ["Split Window"        split-window-vertically t]
  45.       ["Un-Split (Keep This)"    delete-other-windows    (not (one-window-p t))]
  46.       ["Un-Split (Keep Others)"    delete-window        (not (one-window-p t))]
  47.       "-----"
  48.       ["Revert Buffer"        revert-buffer         t  nil]
  49.       ["Delete Buffer"        kill-this-buffer     t  nil]
  50.       "-----"
  51.       ["Exit XEmacs"        save-buffers-kill-emacs    t]
  52.       )
  53.  
  54.      ("Edit"
  55.       :filter edit-menu-filter
  56.       ["Undo"            advertised-undo           t]
  57.       ["Cut"            x-kill-primary-selection   t]
  58.       ["Copy"            x-copy-primary-selection   t]
  59.       ["Paste"            x-yank-clipboard-selection t]
  60.       ["Clear"            x-delete-primary-selection t]
  61.       "----"
  62.       ["Search..."        isearch-forward        t]
  63.       ["Search Backward..."    isearch-backward    t]
  64.       ["Replace..."        query-replace        t]
  65.       "----"
  66.       ["Search (Regexp)..."    isearch-forward-regexp    t]
  67.       ["Search Backward (Regexp)..." isearch-backward-regexp t]
  68.       ["Replace (Regexp)..."    query-replace-regexp    t]
  69.       "----"
  70.       ["Goto Line..."        goto-line        t]
  71.       ["What Line"        what-line        t]
  72.       "----"
  73.       ["Start Macro Recording"    start-kbd-macro          (not defining-kbd-macro)]
  74.       ["End Macro Recording"    end-kbd-macro        defining-kbd-macro]
  75.       ["Execute Last Macro"    call-last-kbd-macro    last-kbd-macro]
  76.       "----"
  77.       ["Show Message Log"    show-message-log    t]
  78.       )
  79.  
  80.      ("Apps"
  81.       ["Read Mail (VM)..."    vm            t]
  82.       ["Read Mail (MH)..."    (mh-rmail t)        t]
  83.       ["Send mail..."        mail            t]
  84.       ["Usenet News"        gnus            t]
  85.       ["Browse the Web"        w3            t]
  86.       ["Gopher"            gopher            t]
  87.       ["Hyperbole..."        hyperbole        t]
  88.       "----"
  89.       ["Spell-Check Buffer"    ispell-buffer        t]
  90.       ["Emulate VI"        viper-mode        t]
  91.       "----"
  92.       ("Calendar"
  93.        ["3-Month Calendar"    calendar        t]
  94.        ["Diary"            diary            t]
  95.        ["Holidays"        holidays        t]
  96.        ;; we're all pagans at heart ...
  97.        ["Phases of the Moon"    phases-of-moon        t]
  98.        ["Sunrise/Sunset"    sunrise-sunset        t]
  99.        )
  100.       ("Games"
  101.        ["Quote from Zippy"    yow            t]
  102.        ["Psychoanalyst"        doctor            t]
  103.        ["Psychoanalyze Zippy!"    psychoanalyze-pinhead    t]
  104.        ["Random Flames"        flame            t]
  105.        ["Dunnet (Adventure)"    dunnet            t]
  106.        ["Towers of Hanoi"    hanoi            t]
  107.        ["Game of Life"        life            t]
  108.        ["Multiplication Puzzle"    mpuz            t]
  109.        )
  110.       )
  111.  
  112.      ("Options"
  113.       ["Read Only" (toggle-read-only)
  114.        :style toggle :selected buffer-read-only]
  115.       ("Editing Options"
  116.        ["Overstrike" (progn
  117.                (overwrite-mode current-prefix-arg)
  118.                (setq-default overwrite-mode overwrite-mode))
  119.     :style toggle :selected overwrite-mode]
  120.        ["Case Sensitive Search" (progn
  121.                   (setq case-fold-search (not case-fold-search))
  122.                   (setq-default case-fold-search
  123.                         case-fold-search))
  124.     :style toggle :selected (not case-fold-search)]
  125.        ["Case Matching Replace" (setq case-replace (not case-replace))
  126.     :style toggle :selected case-replace]
  127.        ["Auto Delete Selection" (if (memq 'pending-delete-pre-hook
  128.                       pre-command-hook)
  129.                     (pending-delete-off nil)
  130.                   (pending-delete-on nil))
  131.     :style toggle
  132.     :selected (memq 'pending-delete-pre-hook pre-command-hook)]
  133.        ["Active Regions" (setq zmacs-regions (not zmacs-regions))
  134.     :style toggle :selected zmacs-regions]
  135.        ["Mouse Paste At Text Cursor" (setq mouse-yank-at-point
  136.                        (not mouse-yank-at-point))
  137.     :style toggle :selected mouse-yank-at-point]
  138.        )
  139.       ("General Options"
  140.        ["Teach Extended Commands" (setq teach-extended-commands-p
  141.                     (not teach-extended-commands-p))
  142.     :style toggle :selected teach-extended-commands-p]
  143.        ["Debug On Error" (setq debug-on-error (not debug-on-error))
  144.     :style toggle :selected debug-on-error]
  145.        ["Debug On Quit" (setq debug-on-quit (not debug-on-quit))
  146.     :style toggle :selected debug-on-quit]
  147.        )
  148.       ("\"Other Window\" Location"
  149.        ["Always in Same Frame"
  150.     (setq get-frame-for-buffer-default-instance-limit nil)
  151.     :style radio
  152.     :selected (null get-frame-for-buffer-default-instance-limit)]
  153.        ["Other Frame (2 Frames Max)"
  154.     (setq get-frame-for-buffer-default-instance-limit 2)
  155.     :style radio
  156.     :selected (eq 2 get-frame-for-buffer-default-instance-limit)]
  157.        ["Other Frame (3 Frames Max)"
  158.     (setq get-frame-for-buffer-default-instance-limit 3)
  159.     :style radio
  160.     :selected (eq 3 get-frame-for-buffer-default-instance-limit)]
  161.        ["Other Frame (4 Frames Max)"
  162.     (setq get-frame-for-buffer-default-instance-limit 4)
  163.     :style radio
  164.     :selected (eq 4 get-frame-for-buffer-default-instance-limit)]
  165.        ["Other Frame (5 Frames Max)"
  166.     (setq get-frame-for-buffer-default-instance-limit 5)
  167.     :style radio
  168.     :selected (eq 5 get-frame-for-buffer-default-instance-limit)]
  169.        ["Always Create New Frame"
  170.     (setq get-frame-for-buffer-default-instance-limit 0)
  171.     :style radio
  172.     :selected (eq 0 get-frame-for-buffer-default-instance-limit)]
  173.        "-----"
  174.        ["Temp Buffers Always in Same Frame"
  175.     (setq temp-buffer-show-function 'show-temp-buffer-in-current-frame)
  176.     :style radio
  177.     :selected (eq temp-buffer-show-function
  178.               'show-temp-buffer-in-current-frame)]
  179.        ["Temp Buffers Like Other Buffers"
  180.     (setq temp-buffer-show-function nil)
  181.     :style radio
  182.     :selected (null temp-buffer-show-function)]
  183.        )
  184.  
  185.       "-----"
  186.       ("Syntax Highlighting" 
  187.        ["None" (progn
  188.          (font-lock-mode 0)
  189.          (fast-lock-mode 0))
  190.     :style radio :selected (null font-lock-mode)]
  191.        ["Fonts" (progn (require 'font-lock)
  192.                (font-lock-use-default-fonts)
  193.                (setq font-lock-use-fonts t
  194.                  font-lock-use-colors nil)
  195.                (font-lock-mode 1))
  196.     :style radio
  197.     :selected (and font-lock-mode
  198.                font-lock-use-fonts)]
  199.        ["Colors" (progn (require 'font-lock)
  200.             (font-lock-use-default-colors)
  201.             (setq font-lock-use-colors t 
  202.                   font-lock-use-fonts nil)
  203.             (font-lock-mode 1))
  204.     :style radio
  205.     :selected (and font-lock-mode
  206.                font-lock-use-colors)]
  207.        "-----"
  208.        ["Less" (progn (require 'font-lock)
  209.               (font-lock-use-default-minimal-decoration)
  210.               (setq font-lock-use-maximal-decoration nil)
  211.               (font-lock-mode 0)
  212.               (font-lock-mode 1))
  213.     :style radio
  214.     :selected (and font-lock-mode
  215.                (not font-lock-use-maximal-decoration))]
  216.        ["More" (progn (require 'font-lock)
  217.               (font-lock-use-default-maximal-decoration)
  218.               (setq font-lock-use-maximal-decoration t)
  219.               (font-lock-mode 0)
  220.               (font-lock-mode 1))
  221.     :style radio
  222.     :selected (and font-lock-mode
  223.                font-lock-use-maximal-decoration)]
  224.        "-----"
  225.        ["Fast" (progn (require 'fast-lock)
  226.               (if fast-lock-mode
  227.               (progn
  228.                 (fast-lock-mode 0)
  229.                 ;; this shouldn't be necessary so there has to
  230.                 ;; be a redisplay bug lurking somewhere (or
  231.                 ;; possibly another event handler bug)
  232.                 (redraw-modeline))
  233.             (if font-lock-mode
  234.                 (progn
  235.                   (fast-lock-mode 1)
  236.                   (redraw-modeline)))))
  237.     :active font-lock-mode
  238.     :style toggle
  239.     :selected fast-lock-mode]
  240.        ["Auto-Fontify" (if (not (featurep 'font-lock))
  241.                (progn
  242.                  (setq font-lock-auto-fontify t)
  243.                  (require 'font-lock))
  244.              (setq font-lock-auto-fontify
  245.                    (not font-lock-auto-fontify)))
  246.     :style toggle
  247.     :selected (and (featurep 'font-lock) font-lock-auto-fontify)]
  248.        )
  249.       ("Paren Highlighting"
  250.        ["None" (paren-set-mode -1)
  251.     :style radio :selected (not paren-mode)]
  252.        ["Blinking Paren" (paren-set-mode 'blink-paren)
  253.     :style radio :selected (eq paren-mode 'blink-paren)]
  254.        ["Steady Paren" (paren-set-mode 'paren)
  255.     :style radio :selected (eq paren-mode 'paren)]
  256.        ["Expression" (paren-set-mode 'sexp)
  257.     :style radio :selected (eq paren-mode 'sexp)]
  258. ;;;       ["Nested Shading" (paren-set-mode 'nested)
  259. ;;;        :style radio :selected (eq paren-mode 'nested)]
  260.        )
  261.       "-----"
  262.       ("Frame Appearance"
  263.        ["Scrollbars" (if (= (specifier-instance scrollbar-width) 0)
  264.              (progn
  265.                (set-specifier scrollbar-width 15)
  266.                (set-specifier scrollbar-height 15))
  267.                (set-specifier scrollbar-width 0)
  268.                (set-specifier scrollbar-height 0))
  269.     :style toggle :selected (> (specifier-instance scrollbar-width) 0)]
  270.        ["3D Modeline"
  271.     (progn
  272.       (if (zerop (specifier-instance modeline-shadow-thickness))
  273.           (set-specifier modeline-shadow-thickness 2)
  274.         (set-specifier modeline-shadow-thickness 0))
  275.       (redraw-modeline t))
  276.     :style toggle :selected
  277.     (let ((thickness
  278.            (specifier-instance modeline-shadow-thickness)))
  279.       (and (integerp thickness)
  280.            (> thickness 0)))]
  281.        ["Truncate Lines" (progn
  282.                (setq truncate-lines (not truncate-lines))
  283.                (setq-default truncate-lines truncate-lines))
  284.     :style toggle :selected truncate-lines]
  285.        ["Bar Cursor" (progn
  286.                (setq bar-cursor (not bar-cursor))
  287.                (force-cursor-redisplay))
  288.     :style toggle :selected bar-cursor]
  289. ;     ["Line Numbers" (line-number-mode nil)
  290. ;      :style toggle :selected line-number-mode]
  291.       )
  292.       ("Menubar Appearance"
  293.        ["Buffers Menu Length..."
  294.     (progn
  295.       (setq buffers-menu-max-size
  296.         (read-number
  297.          "Enter number of buffers to display (or 0 for unlimited): "))
  298.       (if (eq buffers-menu-max-size 0) (setq buffers-menu-max-size nil)))
  299.     t]
  300.        ["Buffers Sub-Menus" (setq complex-buffers-menu-p
  301.                   (not complex-buffers-menu-p))
  302.     :style toggle :selected complex-buffers-menu-p]
  303.        ["Frame-Local Font Menu" (setq font-menu-this-frame-only-p
  304.                     (not font-menu-this-frame-only-p))
  305.     :style toggle :selected font-menu-this-frame-only-p]
  306.        ["Ignore Scaled Fonts" (setq font-menu-ignore-scaled-fonts
  307.                     (not font-menu-ignore-scaled-fonts))
  308.     :style toggle :selected font-menu-ignore-scaled-fonts]
  309.        )
  310.       ("Toolbar Appearance"
  311.        ["Visible" (menubar-toggle-toolbar-visibility)
  312.     :style toggle :selected
  313.     (menubar-toolbar-visible-p)]
  314.        ["Captioned" (if (featurep 'toolbar)
  315.             (set-specifier toolbar-buttons-captioned-p
  316.                        (not (specifier-instance
  317.                          toolbar-buttons-captioned-p))))
  318.     :style toggle :selected
  319.     (and (featurep 'toolbar)
  320.          (specifier-instance toolbar-buttons-captioned-p))]
  321.        ("Default Location"
  322.     ["Top" (menubar-change-default-toolbar-position 'top nil)
  323.      :style radio :selected (eq (default-toolbar-position) 'top)]
  324.     ["Bottom" (menubar-change-default-toolbar-position 'bottom nil)
  325.      :style radio :selected (eq (default-toolbar-position) 'bottom)]
  326.     ["Left" (menubar-change-default-toolbar-position 'left nil)
  327.      :style radio :selected (eq (default-toolbar-position) 'left)]
  328.     ["Right" (menubar-change-default-toolbar-position 'right nil)
  329.      :style radio :selected (eq (default-toolbar-position) 'right)]
  330.     )
  331.        )
  332.       "-----"
  333.       ["Edit Faces..." edit-faces t]
  334.       ("Font"   :filter font-menu-family-constructor)
  335.       ("Size"    :filter font-menu-size-constructor)
  336.       ("Weight"    :filter font-menu-weight-constructor)
  337.       "-----"
  338.       ["Save Options" save-options-menu-settings t]
  339.       )
  340.      
  341.      ("Buffers"
  342.       :filter buffers-menu-filter
  343.       ["List All Buffers" list-buffers t]
  344.       "--"
  345.       )
  346.      
  347.      ("Tools"
  348.       ["Grep..."        grep            t]
  349.       ["Compile..."        compile            t]
  350.       ["Shell Command..."    shell-command        t]
  351.       ["Shell Command on Region..."
  352.                 shell-command-on-region (region-exists-p)]
  353.       ["Debug (GDB)..."        gdb            t]
  354.       ["Debug (DBX)..."        dbx            t]
  355.       "-----"
  356.       ["OO-Browser..."        oobr            t]
  357.       ("Tags"
  358.        ["Find..."        find-tag        t]
  359.        ["Find Other Window..."    find-tag-other-window    t]
  360.        ["Tags Search..."    tags-search        t]
  361.        ["Tags Replace..."    tags-query-replace    t]
  362.        "-----"
  363.        ["Continue"        tags-loop-continue    t]
  364.        ["Pop stack"        pop-tag-mark        t]
  365.        ["Apropos..."        tags-apropos        t]))
  366.  
  367.      nil        ; the partition: menus after this are flushright
  368.  
  369.      ("Help"
  370.       ["About XEmacs..."    about-xemacs        t]
  371.       "-----"
  372.       ["XEmacs WWW Page"    xemacs-www-page        t]
  373.       ["Newest XEmacs FAQ via WWW"    xemacs-www-faq    t]
  374.       ["XEmacs FAQ (local)"    xemacs-local-faq    t]
  375.       ["XEmacs Tutorial"    help-with-tutorial    t]
  376.       ["XEmacs News"        view-emacs-news        t]
  377.       "-----"
  378.       ["Info (Detailed Docs)"    info            t]
  379.       ("Lookup in Info"
  380.        ["Key/Mouse Binding..."    Info-goto-emacs-key-command-node t]
  381.        ["Command..."        Info-goto-emacs-command-node t]
  382.        ["Elisp Function..."    Info-elisp-ref        t]
  383.        ["Topic..."        Info-query        t])
  384.       ["Package Browser"    finder-by-keyword    t]
  385.       ["Describe Mode"        describe-mode        t]
  386.       ["Apropos..."        hyper-apropos        t]
  387.       ["Super Apropos..."    super-apropos        t]
  388.       "-----"
  389.       ["Describe Key/Mouse..."    describe-key        t]
  390.       ["List Key Bindings"    describe-bindings    t]
  391.       ["List Mouse Bindings"    describe-pointer    t]
  392.       "-----"
  393.       ["Describe Function..."    describe-function    t]
  394.       ["Describe Variable..."    describe-variable    t]
  395.       ["Where Is Command..."    where-is        t]
  396.       "-----"
  397.       ["Unix Manual..."        manual-entry        t]
  398.       ("Misc"
  399.        ["Describe No Warranty"    describe-no-warranty    t]
  400.        ["Describe XEmacs License" describe-copying    t]
  401.        ["Getting the Latest Version"    describe-distribution    t])
  402.       )
  403.      )))
  404.  
  405.  
  406. ;; These functions make a very big assumption: that you never
  407. ;; maninpulate the things they do other than through them.
  408. ;; Cheap.  Cheap.  Cheap.   #### Add toolbar-visible-p for 19.14.
  409.  
  410. ;; Change the default toolbar location and adjust the toolbar width
  411. ;; and height accordingly.
  412. ;; #### The height/width is what is hard-coded in src/toolbar.h
  413. (defun menubar-change-default-toolbar-position (new-location &optional force)
  414.   (let ((top-height (if (eq new-location 'top) 37 0))
  415.     (bottom-height (if (eq new-location 'bottom) 37 0))
  416.     (left-width (if (eq new-location 'left) 37 0))
  417.     (right-width (if (eq new-location 'right) 37 0)))
  418.     (if (not (eq new-location 'none))
  419.     (set-default-toolbar-position new-location))
  420.     (if (or force (menubar-toolbar-visible-p))
  421.     (progn
  422.       (set-specifier top-toolbar-height top-height)
  423.       (set-specifier bottom-toolbar-height bottom-height)
  424.       (set-specifier left-toolbar-width left-width)
  425.       (set-specifier right-toolbar-width right-width)))))
  426.  
  427. ;; Return nil if the size of all 4 toolbars is 0, otherwise t.
  428. (defun menubar-toolbar-visible-p ()
  429.   (if (not (featurep 'toolbar))
  430.       nil
  431.     (if (and (eq (specifier-instance top-toolbar-height) 0)
  432.          (eq (specifier-instance bottom-toolbar-height) 0)
  433.          (eq (specifier-instance left-toolbar-width) 0)
  434.          (eq (specifier-instance right-toolbar-width) 0))
  435.     nil
  436.       t)))
  437.       
  438. ;; If the toolbars are visible according to menubar-toolbar-visible-p
  439. ;; then set the size of all 4 to 0.  Otherwise set the default toolbar
  440. ;; location's size to the default size.
  441. (defun menubar-toggle-toolbar-visibility ()
  442.   (if (featurep 'toolbar)
  443.       (if (not (menubar-toolbar-visible-p))
  444.       (menubar-change-default-toolbar-position (default-toolbar-position)
  445.                            t)
  446.     (menubar-change-default-toolbar-position 'none t))))
  447.  
  448.  
  449. ;;; Add Load Init button to menubar when starting up with -q
  450. (defun maybe-add-init-button ()
  451.   ;; by Stig@hackvan.com
  452.   (if init-file-user
  453.       nil
  454.     (add-menu-button nil
  455.              ["Load .emacs"
  456.               (progn (delete-menu-item '("Load .emacs"))
  457.                  (load-user-init-file (user-login-name)))
  458.               t]
  459.              "Help")
  460.     ))
  461.  
  462. (add-hook 'before-init-hook 'maybe-add-init-button)
  463.  
  464.  
  465. ;;; The File and Edit menus
  466.  
  467. (defvar put-buffer-names-in-file-menu t)
  468.  
  469. ;; The sensitivity part of this function could be done by just adding forms
  470. ;; to evaluate to the menu items themselves; that would be marginally less
  471. ;; efficient but not perceptibly so (I think).  But in order to change the
  472. ;; names of the Undo menu item and the various things on the File menu item,
  473. ;; we need to use a hook.
  474.  
  475. (defun file-menu-filter (menu-items)
  476.   "Incrementally update the file menu.
  477. This function changes the arguments and sensitivity of these File menu items:
  478.  
  479.   Delete Buffer  has the name of the current buffer appended to it.
  480.   Print Buffer   has the name of the current buffer appended to it.
  481.   Pretty-Print Buffer
  482.          has the name of the current buffer appended to it.
  483.   Save           has the name of the current buffer appended to it, and is
  484.                  sensitive only when the current buffer is modified.
  485.   Revert Buffer  has the name of the current buffer appended to it, and is
  486.                  sensitive only when the current buffer has a file.
  487.   Delete Frame   sensitive only when there is more than one frame.
  488.  
  489. The name of the current buffer is only appended to the menu items if
  490. `put-buffer-names-in-file-menu' is non-nil.  This behavior is the default."
  491.   (let* ((bufname (buffer-name))
  492.      (result menu-items)        ; save pointer to start of menu.
  493.      name
  494.      item)
  495.     ;; the contents of the menu items in the file menu are destructively
  496.     ;; modified so that there is as little consing as possible.  This is okay.
  497.     ;; As soon as the result is returned, it is converted to widget_values
  498.     ;; inside lwlib and the lisp menu-items can be safely modified again. 
  499.     (while (setq item (pop menu-items))
  500.       (if (vectorp item)
  501.       (progn
  502.         (setq name (aref item 0))
  503.         (and put-buffer-names-in-file-menu
  504.          (member name '("Save" "Revert Buffer" "Print Buffer"
  505.                 "Pretty-Print Buffer" "Delete Buffer"))
  506.          (>= 4 (length item))
  507.          (aset item 3 bufname))
  508.         (and (string= "Save" name)
  509.          (aset item 2 (buffer-modified-p)))
  510.         (and (string= "Revert Buffer" name)
  511.          (aset item 2 (not (not (or buffer-file-name
  512.                         revert-buffer-function)))))
  513.         (and (string= "Delete Frame" name)
  514.          (aset item 2 (not (eq (next-frame) (selected-frame)))))
  515.         )))
  516.     result))
  517.  
  518. (defun edit-menu-filter (menu-items)
  519.   "For use as an incremental menu construction filter.
  520. This function changes the sensitivity of these Edit menu items:
  521.  
  522.   Cut    sensitive only when emacs owns the primary X Selection.
  523.   Copy   sensitive only when emacs owns the primary X Selection.
  524.   Clear  sensitive only when emacs owns the primary X Selection.
  525.   Paste  sensitive only when there is an owner for the X Clipboard Selection.
  526.   Undo   sensitive only when there is undo information.
  527.          While in the midst of an undo, this is changed to \"Undo More\"."
  528.   (let* (item
  529.     name
  530.     (result menu-items)        ; save pointer to head of list
  531.     (x-dev (eq 'x (device-type (selected-device))))
  532.     (emacs-owns-selection-p (and x-dev (x-selection-owner-p)))
  533.     (clipboard-exists-p (and x-dev (x-selection-exists-p 'CLIPBOARD)))
  534. ;;;       undo-available undoing-more
  535. ;;;       (undo-info-available (not (null (and (not (eq t buffer-undo-list))
  536. ;;;                                 (if (eq last-command 'undo)
  537. ;;;                                     (setq undoing-more
  538. ;;;                                           (and (boundp 'pending-undo-list)
  539. ;;;                                          pending-undo-list)
  540. ;;;                                   buffer-undo-list))))))
  541.     undo-name undo-state
  542.     )
  543.     ;; As with file-menu-filter, menu-items are destructively modified.
  544.     ;; This is OK.
  545.     (while (setq item (pop menu-items))
  546.       (if (vectorp item)
  547.       (progn
  548.         (setq name (aref item 0))
  549.         (and (member name '("Cut" "Copy" "Clear"))
  550.          (aset item 2 emacs-owns-selection-p))
  551.         (and (string= name "Paste")
  552.          (aset item 2 clipboard-exists-p))
  553.         (and (member name '("Undo" "Undo More"))
  554.          (progn
  555.            ;; we could also do this with the third field of the item.
  556.            (if (eq last-command 'undo)
  557.                (setq undo-name "Undo More"
  558.                  undo-state (not (null (and (boundp 'pending-undo-list)
  559.                             pending-undo-list))))
  560.              (setq undo-name "Undo"
  561.                undo-state (and (not (eq buffer-undo-list t))
  562.                        (not (null
  563.                          (or buffer-undo-list
  564.                              (and (boundp 'pending-undo-list)
  565.                               pending-undo-list)))))))
  566.            (if buffer-read-only (setq undo-state nil))
  567.            (aset item 0 undo-name)
  568.            (aset item 2 undo-state)
  569.            ))
  570.       )))
  571.     result))
  572.  
  573.  
  574. ;;; The Buffers menu
  575.  
  576. ;; this version is too slow
  577. (defun slow-format-buffers-menu-line (buffer)
  578.   "Returns a string to represent the given buffer in the Buffer menu.
  579. nil means the buffer shouldn't be listed.  You can redefine this."
  580.   (if (string-match "\\` " (buffer-name buffer))
  581.       nil
  582.     (save-excursion
  583.      (set-buffer buffer)
  584.      (let ((size (buffer-size)))
  585.        (format "%s%s %-19s %6s %-15s %s"
  586.            (if (buffer-modified-p) "*" " ")
  587.            (if buffer-read-only "%" " ")
  588.            (buffer-name)
  589.            size
  590.            mode-name
  591.            (or (buffer-file-name) ""))))))
  592.  
  593. (defun format-buffers-menu-line (buffer)
  594.   "Returns a string to represent the given buffer in the Buffer menu.
  595. nil means the buffer shouldn't be listed.  You can redefine this."
  596.   (if (string-match "\\` " (setq buffer (buffer-name buffer)))
  597.       nil
  598.     buffer))
  599.  
  600. (defvar buffers-menu-max-size 20
  601.   "*Maximum number of entries which may appear on the \"Buffers\" menu.
  602. If this is 10, then only the ten most-recently-selected buffers will be
  603. shown.  If this is nil, then all buffers will be shown.  Setting this to
  604. a large number or nil will slow down menu responsiveness.")
  605.  
  606. (defvar complex-buffers-menu-p nil
  607.   "*If true, the buffers menu will contain several commands, as submenus
  608. of each buffer line.  If this is false, then there will be only one command:
  609. select that buffer.")
  610.  
  611. (defvar buffers-menu-switch-to-buffer-function 'switch-to-buffer
  612.   "*The function to call to select a buffer from the buffers menu.
  613. `switch-to-buffer' is a good choice, as is `pop-to-buffer'.")
  614.  
  615.  
  616. (defun buffer-menu-save-buffer (buffer)
  617.   (save-excursion
  618.     (set-buffer buffer)
  619.     (save-buffer)))
  620.  
  621. (defun buffer-menu-write-file (buffer)
  622.   (save-excursion
  623.     (set-buffer buffer)
  624.     (write-file (read-file-name
  625.          (format "Write %s to file: "
  626.              (buffer-name (current-buffer)))))))
  627.  
  628. (defsubst build-buffers-menu-internal (buffers)
  629.   (let (name line)
  630.     (mapcar
  631.      (if complex-buffers-menu-p
  632.      #'(lambda (buffer)
  633.          (if (setq line (format-buffers-menu-line buffer))
  634.          (delq nil
  635.            (list line
  636.                (vector "Switch to Buffer"
  637.                    (list buffers-menu-switch-to-buffer-function
  638.                      (setq name (buffer-name buffer)))
  639.                    t)
  640.                (if (eq buffers-menu-switch-to-buffer-function
  641.                    'switch-to-buffer)
  642.                (vector "Switch to Buffer, Other Frame"
  643.                    (list 'switch-to-buffer-other-frame
  644.                      (setq name (buffer-name buffer)))
  645.                    t)
  646.              nil)
  647.                (if (and (buffer-modified-p buffer)
  648.                 (buffer-file-name buffer))
  649.                (vector "Save Buffer"
  650.                    (list 'buffer-menu-save-buffer name) t)
  651.                  ["Save Buffer" nil nil]
  652.                )
  653.                (vector "Save As..."
  654.                    (list 'buffer-menu-write-file name) t)
  655.                (vector "Delete Buffer" (list 'kill-buffer name) t)))))
  656.        #'(lambda (buffer)
  657.        (if (setq line (format-buffers-menu-line buffer))
  658.            (vector line
  659.                (list buffers-menu-switch-to-buffer-function
  660.                  (buffer-name buffer))
  661.                t))))
  662.      buffers)))
  663.  
  664. (defun buffers-menu-filter (menu)
  665.   "This is the menu filter for the top-level buffers \"Buffers\" menu.
  666. It dynamically creates a list of buffers to use as the contents of the menu.
  667. Only the most-recently-used few buffers will be listed on the menu, for
  668. efficiency reasons.  You can control how many buffers will be shown by
  669. setting `buffers-menu-max-size'.  You can control the text of the menu
  670. items by redefining the function `format-buffers-menu-line'."
  671.   (let ((buffers (buffer-list)))
  672.     (and (integerp buffers-menu-max-size)
  673.      (> buffers-menu-max-size 1)
  674.      (> (length buffers) buffers-menu-max-size)
  675.      ;; shorten list of buffers
  676.      (setcdr (nthcdr buffers-menu-max-size buffers) nil))
  677.       (setq buffers (delq nil (build-buffers-menu-internal buffers)))
  678.       (append menu buffers)
  679.       ))
  680.  
  681.  
  682.  
  683. ;;; The Options menu
  684.  
  685. (defconst options-menu-saved-forms
  686.   ;; This is really quite a kludge, but it gets the job done.
  687.   (purecopy
  688.    '(overwrite-mode            ; #### - does this WORK???
  689.      teach-extended-commands-p
  690.      bar-cursor
  691.      debug-on-error
  692.      debug-on-quit
  693.      get-frame-for-buffer-default-instance-limit
  694.      temp-buffer-show-function
  695.      complex-buffers-menu-p
  696.      font-menu-ignore-scaled-fonts
  697.      font-menu-this-frame-only-p
  698.      buffers-menu-max-size
  699.      case-fold-search
  700.      case-replace
  701.      zmacs-regions
  702.      truncate-lines
  703.      mouse-yank-at-point
  704.      ;; We only save global settings since the others will belong to
  705.      ;; objects which only exist during this session.
  706.      `(set-default-toolbar-position
  707.        ',(default-toolbar-position))
  708.      `(add-spec-list-to-specifier
  709.        top-toolbar-height
  710.        ',(specifier-spec-list top-toolbar-height 'global))
  711.      `(add-spec-list-to-specifier
  712.        bottom-toolbar-height
  713.        ',(specifier-spec-list bottom-toolbar-height 'global))
  714.      `(add-spec-list-to-specifier
  715.        left-toolbar-width
  716.        ',(specifier-spec-list left-toolbar-width 'global))
  717.      `(add-spec-list-to-specifier
  718.        right-toolbar-width
  719.        ',(specifier-spec-list right-toolbar-width 'global))
  720.      `(add-spec-list-to-specifier
  721.        scrollbar-width
  722.        ',(specifier-spec-list scrollbar-width 'global))
  723.      `(add-spec-list-to-specifier
  724.        scrollbar-height
  725.        ',(specifier-spec-list scrollbar-height 'global))
  726.      `(add-spec-list-to-specifier
  727.        modeline-shadow-thickness
  728.        ',(specifier-spec-list modeline-shadow-thickness 'global))
  729.      (if paren-mode
  730.       `(progn (require 'paren) (paren-set-mode ',paren-mode)))
  731.      (if (memq 'pending-delete-pre-hook pre-command-hook)
  732.      '(require 'pending-del))
  733.      ;; Setting this in lisp conflicts with X resources.  Bad move.  --Stig 
  734.      ;; (list 'set-face-font ''default (face-font-name 'default))
  735.      ;; (list 'set-face-font ''modeline (face-font-name 'modeline))
  736.      font-lock-auto-fontify
  737.      font-lock-use-fonts
  738.      font-lock-use-colors
  739.      font-lock-use-maximal-decoration
  740.      font-lock-mode-enable-list
  741.      font-lock-mode-disable-list
  742.      ;; #### - these structures are clearly broken.  There's no way to ever
  743.      ;; un-require font-lock or fast-lock via the menus.  --Stig
  744.      (if (featurep 'font-lock)
  745.      '(require 'font-lock))
  746.      (if (featurep 'fast-lock)
  747.      '(require 'fast-lock))
  748.      (if (and (boundp 'font-lock-mode-hook)
  749.           (memq 'turn-on-fast-lock font-lock-mode-hook))
  750.      '(add-hook 'font-lock-mode-hook 'turn-on-fast-lock)
  751.        '(remove-hook 'font-lock-mode-hook 'turn-on-fast-lock))
  752.      (cons 'progn
  753.        (apply 'nconc
  754.           (mapcar
  755.            #'(lambda (face)
  756.                (cons
  757.             `(make-face ',face)
  758.             (delq nil
  759.                   (mapcar
  760.                    #'(lambda (property)
  761.                    (if (specifier-spec-list
  762.                     (face-property face property))
  763.                        `(add-spec-list-to-specifier
  764.                      (face-property ',face ',property)
  765.                      ',(save-options-specifier-spec-list face property))))
  766.                    built-in-face-specifiers))))
  767.            (face-list))))
  768.      ))
  769.   "The variables to save; or forms to evaluate to get forms to write out.")
  770.  
  771. (defun save-options-specifier-spec-list (face property)
  772.   (if (not (or (eq property 'font) (eq property 'color)))
  773.       (specifier-spec-list (face-property face property) 'global)
  774.     (let* ((retlist (specifier-spec-list (face-property face property)
  775.                      'global))
  776.        (entry (cdr (car retlist)))
  777.        item)
  778.       (while entry
  779.     (setq item (car entry))
  780.     (if (eq property 'font)
  781.         (if (font-instance-p (cdr item))
  782.         (setcdr item (font-instance-name (cdr item))))
  783.       (if (color-instance-p (cdr item))
  784.           (setcdr item (color-instance-name (cdr item)))))
  785.     (setq entry (cdr entry)))
  786.       retlist)))
  787.  
  788. (defvar save-options-file (concat "~" init-file-user "/.emacs")
  789.     "File to save options into.")
  790.  
  791. (defun save-options-menu-settings ()
  792.   "Saves the current settings of the `Options' menu to your `.emacs' file."
  793.   (interactive)
  794.   (let ((output-buffer (find-file-noselect
  795.                 (expand-file-name save-options-file)))
  796.                 output-marker)
  797.     (save-excursion
  798.       (set-buffer output-buffer)
  799.       ;;
  800.       ;; Find and delete the previously saved data, and position to write.
  801.       ;;
  802.       (goto-char (point-min))
  803.       (if (re-search-forward "^;; Options Menu Settings *\n" nil 'move)
  804.       (let ((p (match-beginning 0)))
  805.         (goto-char p)
  806.         (or (re-search-forward
  807.          "^;; End of Options Menu Settings *\\(\n\\|\\'\\)"
  808.          nil t)
  809.         (error "can't find END of saved state in .emacs"))
  810.         (delete-region p (match-end 0)))
  811.     (goto-char (point-max))
  812.     (insert "\n"))
  813.       (setq output-marker (point-marker))
  814.  
  815.       ;; run with current-buffer unchanged so that variables are evaluated in
  816.       ;; the current context, instead of in the context of the ".emacs" buffer.
  817.       (let ((print-readably t)
  818.         (print-escape-newlines t)
  819.         (standard-output output-marker))
  820.     (princ ";; Options Menu Settings\n")
  821.     (princ ";; =====================\n")
  822.     (princ "(cond\n")
  823.     (princ " ((and (string-match \"XEmacs\" emacs-version)\n")
  824.     (princ "       (boundp 'emacs-major-version)\n")
  825.     (princ "       (= emacs-major-version 19)\n")
  826.     (princ "       (>= emacs-minor-version 12))\n")
  827.     (mapcar #'(lambda (var)
  828.             (princ "  ")
  829.             (if (symbolp var)
  830.             (prin1 (list 'setq-default var
  831.                      (let ((val (symbol-value var)))
  832.                        (if (or (memq val '(t nil))
  833.                            (not (symbolp val)))
  834.                        val
  835.                      (list 'quote val)))))
  836.               (setq var (eval var))
  837.               (cond ((eq (car-safe var) 'progn)
  838.                  (while (setq var (cdr var))
  839.                    (prin1 (car var))
  840.                    (princ "\n")
  841.                    (if (cdr var) (princ "  "))
  842.                    ))
  843.                 (var
  844.                  (prin1 var))))
  845.             (if var (princ "\n")))
  846.         options-menu-saved-forms)
  847.     (princ "  ))\n")
  848.     (princ ";; ============================\n")
  849.     (princ ";; End of Options Menu Settings\n")
  850.     ))
  851.     (set-marker output-marker nil)
  852.     (save-excursion
  853.       (set-buffer output-buffer)
  854.       (save-buffer))
  855.     ))
  856.  
  857.  
  858. (set-menubar default-menubar)
  859.  
  860.  
  861. ;;; Popup menus.
  862.  
  863. (defconst default-popup-menu
  864.   '("XEmacs Commands"
  865.     ["Undo"        advertised-undo        t]
  866.     ["Cut"        x-kill-primary-selection   t]
  867.     ["Copy"        x-copy-primary-selection   t]
  868.     ["Paste"        x-yank-clipboard-selection t]
  869.     "-----"
  870.     ["Select Block"    mark-paragraph         t]
  871.     ["Split Window"    (split-window)        t]
  872.     ["Unsplit Window"     delete-other-windows    t]
  873.     ))
  874.  
  875. (defvar global-popup-menu nil
  876.   "The global popup menu.  This is present in all modes.
  877. See the function `popup-menu' for a description of menu syntax.")
  878.  
  879. (defvar mode-popup-menu nil
  880.   "The mode-specific popup menu.  Automatically buffer local.
  881. This is appended to the default items in `global-popup-menu'.
  882. See the function `popup-menu' for a description of menu syntax.")
  883. (make-variable-buffer-local 'mode-popup-menu)
  884.  
  885. ;; In an effort to avoid massive menu clutter, this mostly worthless menu is
  886. ;; superceded by any local popup menu...
  887. (setq-default mode-popup-menu default-popup-menu)
  888.  
  889. (defvar activate-popup-menu-hook nil
  890.   "Function or functions run before a mode-specific popup menu is made visible.
  891. These functions are called with no arguments, and should interrogate and
  892. modify the value of `global-popup-menu' or `mode-popup-menu' as desired.
  893. Note: this hook is only run if you use `popup-mode-menu' for activating the
  894. global and mode-specific commands; if you have your own binding for button3,
  895. this hook won't be run.")
  896.  
  897. (defun popup-mode-menu ()
  898.   "Pop up a menu of global and mode-specific commands.
  899. The menu is computed by combining `global-popup-menu' and `mode-popup-menu'."
  900.   (interactive "@_")
  901.   (run-hooks 'activate-popup-menu-hook)
  902.   (popup-menu
  903.    (cond ((and global-popup-menu mode-popup-menu)
  904.       (check-menu-syntax mode-popup-menu)
  905.       (let ((title (car mode-popup-menu))
  906.         (items (cdr mode-popup-menu)))
  907.         (append global-popup-menu
  908.             '("---" "---")
  909.             (if popup-menu-titles (list title))
  910.             (if popup-menu-titles '("---" "---"))
  911.             items)))
  912.      (t
  913.       (or mode-popup-menu
  914.           global-popup-menu
  915.           (error "No menu here."))))))
  916.  
  917. (defun popup-buffer-menu (event) 
  918.   "Pop up a copy of the Buffers menu (from the menubar) where the mouse is clicked."
  919.   (interactive "e")
  920.   (let ((window (and (event-over-text-area-p event) (event-window event)))
  921.     (bmenu nil))
  922.     (or window
  923.     (error "Pointer must be in a normal window"))
  924.     (select-window window)
  925.     (if current-menubar
  926.      (setq bmenu (assoc "Buffers" current-menubar)))
  927.     (if (null bmenu)
  928.      (setq bmenu (assoc "Buffers" default-menubar)))
  929.     (if (null bmenu)
  930.      (error "Can't find the Buffers menu"))
  931.     (popup-menu bmenu)))
  932.  
  933. (defun popup-menubar-menu (event) 
  934.   "Pop up a copy of menu that also appears in the menubar"
  935.   ;; by Stig@hackvan.com
  936.   (interactive "e")
  937.   (let ((window (and (event-over-text-area-p event) (event-window event)))
  938.     popup-menubar)
  939.     (or window
  940.     (error "Pointer must be in a normal window"))
  941.     (select-window window)
  942.     (and current-menubar (run-hooks 'activate-menubar-hook))
  943.     ;; ##### Instead of having to copy this just to safely get rid of
  944.     ;; any nil what we should really do is fix up the internal menubar
  945.     ;; code to just ignore nil if generating a popup menu
  946.     (setq popup-menubar (delete nil (copy-sequence (or current-menubar
  947.                                default-menubar))))
  948.     (popup-menu (cons "Menubar Menu" popup-menubar))
  949.     ))
  950.  
  951. (global-set-key 'button3 'popup-mode-menu)
  952. ;; shift button3 and shift button2 are reserved for Hyperbole
  953. (global-set-key '(meta control button3) 'popup-buffer-menu)
  954. (global-set-key '(meta shift button3) 'popup-menubar-menu)
  955.  
  956. ;; Here's a test of the cool new menu features (from Stig).
  957.  
  958. ;(setq mode-popup-menu
  959. ;      '("Test Popup Menu"
  960. ;        :filter cdr
  961. ;        ["this item won't appear because of the menu filter" ding t]
  962. ;        "--:singleLine"
  963. ;        "singleLine"
  964. ;        "--:doubleLine"
  965. ;        "doubleLine"
  966. ;        "--:singleDashedLine"
  967. ;        "singleDashedLine"
  968. ;        "--:doubleDashedLine"
  969. ;        "doubleDashedLine"
  970. ;        "--:noLine"
  971. ;        "noLine"
  972. ;        "--:shadowEtchedIn"
  973. ;        "shadowEtchedIn"
  974. ;        "--:shadowEtchedOut"
  975. ;        "shadowEtchedOut"
  976. ;        "--:shadowDoubleEtchedIn"
  977. ;        "shadowDoubleEtchedIn"
  978. ;        "--:shadowDoubleEtchedOut"
  979. ;        "shadowDoubleEtchedOut"
  980. ;        "--:shadowEtchedInDash"
  981. ;        "shadowEtchedInDash"
  982. ;        "--:shadowEtchedOutDash"
  983. ;        "shadowEtchedOutDash"
  984. ;        "--:shadowDoubleEtchedInDash"
  985. ;        "shadowDoubleEtchedInDash"
  986. ;        "--:shadowDoubleEtchedOutDash"
  987. ;        "shadowDoubleEtchedOutDash"
  988. ;        ))
  989.  
  990.  
  991. (provide 'x-menubar)
  992.  
  993. ;;; x-menubar.el ends here.
  994.